home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / infix / tokenize.scm < prev   
Text File  |  1995-10-13  |  4KB  |  155 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  3.  
  4.  
  5. ; A tokenizer.
  6.  
  7. ; Nonstandard things needed:
  8. ;  record package
  9. ;  char->ascii
  10. ;  peek-char
  11. ;  reverse-list->string
  12. ;  error
  13.  
  14. (define (reverse-list->string l n)
  15.   (list->string (reverse l)))
  16.  
  17. ; Tokenizer tables
  18.  
  19. (define tokenizer-table-type
  20.   (make-record-type 'tokenizer-table
  21.             '(translation dispatch-vector terminating?-vector)))
  22.  
  23. (define make-tokenizer-table
  24.   (let ()
  25.     (define make
  26.       (record-constructor tokenizer-table-type
  27.               '(translation dispatch-vector terminating?-vector)))
  28.     (define (make-tokenizer-table)
  29.       (make (if (char=? (string-ref (symbol->string 't) 0) #\T)
  30.         char-upcase
  31.         char-downcase)
  32.         (make-vector 256 (lambda (c port)
  33.                    (error "illegal character read" c)))
  34.         (make-vector 256 #t)))
  35.     make-tokenizer-table))
  36.  
  37. (define ttab-translation
  38.   (record-accessor tokenizer-table-type 'translation))
  39. (define ttab-dispatch-vector
  40.   (record-accessor tokenizer-table-type 'dispatch-vector))
  41. (define ttab-terminating?-vector
  42.   (record-accessor tokenizer-table-type 'terminating?-vector))
  43.  
  44. (define set-tokenizer-table-translator!
  45.   (record-modifier tokenizer-table-type 'translation))
  46.  
  47. (define (set-char-tokenization! ttab char reader term?)
  48.   (vector-set! (ttab-dispatch-vector ttab) (char->ascii char) reader)
  49.   (vector-set! (ttab-terminating?-vector ttab) (char->ascii char) term?))
  50.  
  51. ; Main dispatch
  52.  
  53. (define (tokenize ttab port)
  54.   (let ((c (read-char port)))
  55.     (if (eof-object? c)
  56.         c
  57.         ((vector-ref (ttab-dispatch-vector ttab) (char->ascii c))
  58.          c port))))
  59.  
  60. ; Atoms (symbols and numbers)
  61.  
  62. (define (scan-atom c ttab port)
  63.   (let ((translate (ttab-translation ttab)))
  64.     (let loop ((l (list (translate c))) (n 1))
  65.       (let ((c (peek-char port)))
  66.     (cond ((or (eof-object? c)
  67.            (vector-ref (ttab-terminating?-vector ttab)
  68.                    (char->ascii c)))
  69.            (reverse-list->string l n))
  70.           (else
  71.            (loop (cons (translate (read-char port)) l)
  72.              (+ n 1))))))))
  73.  
  74. ; Allow ->foo, -v-, etc.
  75.  
  76. (define (parse-atom string)
  77.   (let ((c (string-ref string 0)))
  78.     (cond ((char=? c #\+)
  79.        (parse-possible-number string))
  80.           ((char=? c #\-)
  81.        (parse-possible-number string))
  82.           ((char=? c #\.)
  83.        (parse-possible-number string))
  84.           (else
  85.            (if (char-numeric? c)
  86.                (parse-number string)
  87.                (string->symbol string))))))
  88.  
  89. ; First char is + - .
  90.  
  91. (define (parse-possible-number string)
  92.   (if (and (> (string-length string) 1)
  93.        (char-numeric? (string-ref string 1)))
  94.       (parse-number string)
  95.       (string->symbol string)))
  96.  
  97. (define (parse-number string)
  98.   (or (string->number string 'e 'd)
  99.       (error "unsupported number syntax" string)))
  100.  
  101.  
  102. ; Usual stuff (what you'd expect to be common to Scheme and ML syntax)
  103.  
  104. (define (set-up-usual-tokenization! ttab)
  105.  
  106.   (define (tokenize-whitespace c port)     c ;ignored
  107.     (tokenize ttab port))
  108.  
  109.   (define (tokenize-constituent c port)
  110.     (parse-atom (scan-atom c ttab port)))
  111.  
  112.   (for-each (lambda (c)
  113.           (set-char-tokenization! ttab (ascii->char c)
  114.                       tokenize-whitespace #t))
  115.         ascii-whitespaces)
  116.  
  117.   (for-each (lambda (c)
  118.           (set-char-tokenization! ttab c tokenize-constituent #f))
  119.         (string->list
  120.          (string-append ".0123456789"
  121.                 "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  122.                 "abcdefghijklmnopqrstuvwxyz")))
  123.   
  124.   (set-char-tokenization! ttab #\" tokenize-string #t)
  125.  
  126.   )
  127.  
  128. (define (make-constituent! c ttab)
  129.   (set-char-tokenization! ttab c
  130.               (lambda (c port)
  131.                 (parse-atom (scan-atom c ttab port)))
  132.               #f))
  133.  
  134. (define (tokenize-string c port)      c ;ignored
  135.   (let loop ((l '()) (i 0))
  136.     (let ((c (read-char port)))
  137.       (cond ((eof-object? c)
  138.          (error "end of file within a string"))
  139.         ((char=? c #\\)
  140.          (let ((c (read-char port)))
  141.            (if (or (char=? c #\\) (char=? c #\"))
  142.            (loop (cons c l) (+ i 1))
  143.            (error "invalid escaped character in string" c))))
  144.         ((char=? c #\") (reverse-list->string l i))
  145.         (else (loop (cons c l) (+ i 1)))))))
  146.  
  147. ; Auxiliary for parse-atom and tokenize-string
  148.  
  149. ;(define (reverse-list->string l n)   ;In microcode?
  150. ;  (let ((s (make-string n)))
  151. ;    (do ((l l (cdr l))
  152. ;        (i (- n 1) (- i 1)))
  153. ;       ((< i 0) s)
  154. ;      (string-set! s i (car l)))))
  155.